Celestin Apprentice 5/Apprentice-Release5.iso/Environments/PowerMacOberon feb96/Source/Kepler1.Mod

Oberon Text | 1995-11-22 | 13.7 KB | 411 lines | [TEXT/.Ob4]

Syntax10.Scn.Fnt
MODULE Kepler1;    (* J. Templ, 5.11.90/27.09.93 *)
    IMPORT
        KeplerGraphs, KeplerFrames, KeplerPorts, Math, Oberon, Texts, Files, Fonts, Display, In, Out;
    CONST
        ArrLen1 = 44; ArrLen2 = 28; ArrAngle = Math.pi / 6;    (*30 DEG*)
        fg = Display.white;
    TYPE
        Rectangle* = POINTER TO RectangleDesc;
        RectangleDesc* = RECORD
            (KeplerGraphs.ConsDesc)
        END ;
        Texture* = POINTER TO TextureDesc;
        TextureDesc* = RECORD
            (KeplerGraphs.ConsDesc)
            pat*: INTEGER;
        END ;
        Line* = POINTER TO LineDesc;
        LineDesc* = RECORD
            (KeplerGraphs.ConsDesc)
        END ;
        Circle* = POINTER TO CircleDesc;
        CircleDesc* = RECORD
            (KeplerGraphs.ConsDesc)
        END ;
        Ellipse* = POINTER TO EllipseDesc;
        EllipseDesc* = RECORD
            (KeplerGraphs.ConsDesc)
        END ;
        String* = POINTER TO StringDesc;    (*for backward compatibility only*)
        StringDesc* = RECORD
            (KeplerFrames.CaptionDesc)
        END ;
        HShape* = POINTER TO HShapeDesc;
        HShapeDesc* = RECORD
            (KeplerGraphs.ConsDesc)
        END ;
        H90Shape* = POINTER TO H90ShapeDesc;
        H90ShapeDesc* = RECORD
            (KeplerGraphs.ConsDesc)
        END ;
        AttrLine* = POINTER TO AttrDesc;
        AttrDesc* = RECORD
            (KeplerGraphs.ConsDesc)
            width*, a1*, a2*: INTEGER; (* line width, arrow kind, 0 = no arrow, 1 = 30 deg arrow, 2 = 45 deg arrow *)
        END ;
        Triangle* = POINTER TO TriangleDesc;
        TriangleDesc* = RECORD
            (KeplerGraphs.ConsDesc)
            pat*: INTEGER
        END ;
(* ------------------------------- Rectangle ------------------------------- *)
    PROCEDURE MinMax(x, y: INTEGER; VAR min, max: INTEGER);
    BEGIN IF x < y THEN min := x; max := y ELSE min := y; max := x END
    END MinMax;
    PROCEDURE (R: Rectangle) Draw* (F: KeplerPorts.Port);
        VAR minx, maxx, miny, maxy: INTEGER;
    BEGIN
        MinMax(R.p[0].x, R.p[1].x, minx, maxx);
        MinMax(R.p[0].y, R.p[1].y, miny, maxy);
        F.DrawRect(minx, miny, maxx-minx, maxy-miny, Display.white, Display.replace)
    END Draw;
    PROCEDURE NewRectangle*;
        VAR o: Rectangle;
    BEGIN
        IF KeplerFrames.nofpts >= 2 THEN
            NEW(o); o.nofpts := 2;
            KeplerFrames.ConsumePoint(o.p[0]);
            KeplerFrames.ConsumePoint(o.p[1]);
            KeplerFrames.Focus.Append(o);
        END
    END NewRectangle;
(* ------------------------------- Texture ------------------------------- *)
    PROCEDURE (T: Texture) Draw* (F: KeplerPorts.Port);
        VAR minx, maxx, miny, maxy: INTEGER;
    BEGIN
        MinMax(T.p[0].x, T.p[1].x, minx, maxx);
        MinMax(T.p[0].y, T.p[1].y, miny, maxy);
        F.FillRect(minx, miny, maxx-minx, maxy-miny, Display.white, T.pat, Display.replace)
    END Draw;
    PROCEDURE (T: Texture) Write* (VAR R: Files.Rider);
    BEGIN Files.WriteNum(R, T.pat); T.Write^(R)
    END Write;
    PROCEDURE (T: Texture) Read* (VAR R: Files.Rider);
        VAR i: LONGINT;
    BEGIN Files.ReadNum(R, i); T.pat := SHORT (i); T.Read^(R)
    END Read;
    PROCEDURE NewTexture*;
        VAR o: Texture; i: INTEGER;
    BEGIN
        IF KeplerFrames.nofpts >= 2 THEN
            In.Open; In.Int(i);
            IF In.Done THEN NEW(o); o.nofpts := 2; o.pat := i;
                KeplerFrames.ConsumePoint(o.p[0]);
                KeplerFrames.ConsumePoint(o.p[1]);
                KeplerFrames.Focus.Append(o)
            END
        END
    END NewTexture;
(* ------------------------------- Line ------------------------------- *)
    PROCEDURE (L: Line) Draw* (F: KeplerPorts.Port);
    BEGIN F.DrawLine(L.p[0].x, L.p[0].y, L.p[1].x, L.p[1].y, Display.white, Display.replace)
    END Draw;
    PROCEDURE NewLine*;
        VAR o: Line;
    BEGIN
        IF KeplerFrames.nofpts >= 2 THEN
            NEW(o); o.nofpts := 2;
            KeplerFrames.ConsumePoint(o.p[0]);
            KeplerFrames.ConsumePoint(o.p[1]);
            KeplerFrames.Focus.Append(o);
        END
    END NewLine;
(* ------------------------------- Circle ------------------------------- *)
    PROCEDURE (C: Circle) Draw* (F: KeplerPorts.Port);
        VAR a, b: LONGINT; r: INTEGER;
    BEGIN
        a := C.p[0].x - C.p[1].x; b := C.p[0].y - C.p[1].y;
        r := SHORT(ENTIER(Math.sqrt(a*a + b*b)));
        F.DrawCircle(C.p[0].x, C.p[0].y, r, Display.white, Display.replace)
    END Draw;
    PROCEDURE NewCircle*;
        VAR o: Circle;
    BEGIN
        IF KeplerFrames.nofpts >= 2 THEN
            NEW(o); o.nofpts := 2;
            KeplerFrames.ConsumePoint(o.p[0]);
            KeplerFrames.ConsumePoint(o.p[1]);
            KeplerFrames.Focus.Append(o);
        END
    END NewCircle;
(* ------------------------------- Ellipse ------------------------------- *)
    PROCEDURE (E: Ellipse) Draw* (F: KeplerPorts.Port);
        VAR a, b, tmpx, tmpy, temp : INTEGER;
    BEGIN
        tmpx := E.p[1].x - E.p[0].x; tmpy := E.p[2].y - E.p[0].y;
        MinMax( tmpx, -tmpx, temp, a );
        MinMax( tmpy, -tmpy, temp, b );
        E.p[2].x := E.p[0].x;
        E.p[1].y := E.p[0].y;
        F.DrawEllipse(E.p[0].x, E.p[0].y, a, b, Display.white, Display.replace)
    END Draw;
    PROCEDURE NewEllipse*;
        VAR o: Ellipse;
    BEGIN
        IF KeplerFrames.nofpts >= 3 THEN
            NEW(o); o.nofpts := 3;
            KeplerFrames.ConsumePoint(o.p[0]);
            KeplerFrames.ConsumePoint(o.p[1]);
            KeplerFrames.ConsumePoint(o.p[2]);
            KeplerFrames.Focus.Append(o);
        END
    END NewEllipse;
(* ------------------------------- Captions ------------------------------- *)
    PROCEDURE NewString*;        (*for backward compatibility only*)
        VAR o: KeplerFrames.Caption;
            beg, end, time: LONGINT;
            R: Texts.Reader;
            T: Texts.Text;
            i: INTEGER;
            ch: CHAR;
    BEGIN
        IF KeplerFrames.nofpts >= 1 THEN
            Oberon.GetSelection(T, beg, end, time);
            IF time > 0 THEN
                NEW(o); o.nofpts := 1;
                In.Open; In.Int(i);
                IF ~In.Done THEN o.align := 0 ELSE o.align := SHORT(i) END ;
                KeplerFrames.ConsumePoint(o.p[0]);
                Texts.OpenReader(R, T, beg); Texts.Read(R, ch);
                o.fnt := R.fnt; i := 0;
                WHILE (ch >= " ") & (i < 128) & (Texts.Pos(R) <= end)  DO
                    o.s[i] := ch; INC(i);
                    Texts.Read(R, ch)
                END ;
                o.s[i] := 0X;
                KeplerFrames.Focus.Append(o)
            END
        END
    END NewString;
    PROCEDURE ChangeFont*;
        VAR G: KeplerGraphs.Graph; c: KeplerGraphs.Constellation;
            fntname: ARRAY 32 OF CHAR;
            fnt: Fonts.Font;
            F: KeplerPorts.BalloonPort;
    BEGIN
        In.Open;
        In.Name(fntname);
        KeplerFrames.GetSelection(G);
        IF (G # NIL) & In.Done THEN
            fnt := Fonts.This(fntname);
            IF fntname = fnt.name THEN
                NEW(F); KeplerPorts.InitBalloon(F);
                c := G.cons;
                WHILE c # NIL DO
                    WITH c: KeplerFrames.Caption DO
                        IF c.State() = 2 THEN c.Draw(F); c.fnt := fnt; c.Draw(F) END
                    ELSE
                    END ;
                    c := c.next
                END ;
                G.notify(KeplerGraphs.restore, G, NIL, F)
            END
        END
    END ChangeFont;
    PROCEDURE ChangeAlign*;
        VAR G: KeplerGraphs.Graph; c: KeplerGraphs.Constellation;
            align: INTEGER;
            F: KeplerPorts.BalloonPort;
    BEGIN
        In.Open; In.Int(align);
        KeplerFrames.GetSelection(G);
        IF (G # NIL) & In.Done THEN
            IF (0 <= align) & (align <= 6) THEN
                NEW(F); KeplerPorts.InitBalloon(F);
                c := G.cons;
                WHILE c # NIL DO
                    WITH c: KeplerFrames.Caption DO
                        IF c.State() = 2 THEN c.Draw(F); c.align := SHORT(align); c.Draw(F) END
                    ELSE
                    END ;
                    c := c.next
                END ;
                G.notify(KeplerGraphs.restore, G, NIL, F)
            END
        END
    END ChangeAlign;
(* ------------------------------- HShape ------------------------------- *)
    PROCEDURE (self: HShape) Draw* (F: KeplerPorts.Port);
    BEGIN F.DrawLine(self.p[0].x, self.p[1].y, self.p[2].x, self.p[1].y, Display.white, Display.replace)
    END Draw;
    PROCEDURE NewHShape*;
        VAR h: HShape;
    BEGIN
        IF KeplerFrames.nofpts >= 3 THEN
            NEW(h); h.nofpts := 3;
            KeplerFrames.ConsumePoint(h.p[0]);
            KeplerFrames.ConsumePoint(h.p[1]);
            KeplerFrames.ConsumePoint(h.p[2]);
            KeplerFrames.Focus.Append(h)
        END
    END NewHShape;
(* ------------------------------- H90Shape ------------------------------- *)
    PROCEDURE (self: H90Shape) Draw* (F: KeplerPorts.Port);
    BEGIN F.DrawLine(self.p[1].x, self.p[0].y, self.p[1].x, self.p[2].y, Display.white, Display.replace)
    END Draw;
    PROCEDURE NewH90Shape*;
        VAR h: H90Shape;
    BEGIN
        IF KeplerFrames.nofpts >= 3 THEN
            NEW(h); h.nofpts := 3;
            KeplerFrames.ConsumePoint(h.p[0]);
            KeplerFrames.ConsumePoint(h.p[1]);
            KeplerFrames.ConsumePoint(h.p[2]);
            KeplerFrames.Focus.Append(h)
        END
    END NewH90Shape;
(* ------------------------------- AttrLine ------------------------------- *)
    PROCEDURE Sign ( x : LONGINT ) : INTEGER;
    BEGIN IF x < 0 THEN RETURN - 1 ELSE RETURN 1 END
    END Sign;
    PROCEDURE GetPoint2 ( x, y, dx, dy : LONGINT; angle : REAL; VAR aX, aY : INTEGER; ArrLen: INTEGER );
        VAR h, s : LONGINT; cos, t: REAL;
    BEGIN
        aX := SHORT(x - ENTIER (Math.cos ( angle ) * ArrLen + 0.5) * Sign ( dx ));
        aY := SHORT(y - ENTIER ( Math.sin ( angle ) * ArrLen + 0.5 ) * Sign ( dx ));
    END GetPoint2;
    PROCEDURE DrawArrow (F: KeplerPorts.Port; x1, y1, x2, y2 : LONGINT; ArrLen: INTEGER; ArrAngle: REAL);
        CONST MinLen = 28;
        VAR angle : REAL; dx, dy : LONGINT; ax1, ay1, ax2, ay2: INTEGER;
    BEGIN
        IF ArrLen < MinLen THEN ArrLen := MinLen END ;
        dx := x2 - x1; dy := y2 - y1;
        IF dx # 0 THEN angle := Math.arctan ( dy / dx ) ELSE angle := Sign ( dy ) * ( Math.pi / 2 ) END;
        GetPoint2 ( x2, y2, dx, dy, angle - ArrAngle / 2, ax1, ay1, ArrLen );
        GetPoint2 ( x2, y2, dx, dy, angle + ArrAngle / 2, ax2, ay2, ArrLen );
        F.FillQuad(ax1, ay1, SHORT(x2), SHORT(y2), ax2, ay2, ax2, ay2, fg, 5, Display.replace);
    END DrawArrow;
    PROCEDURE Round(x: REAL): INTEGER;
    BEGIN RETURN SHORT(ENTIER(x + 0.5))
    END Round;
    PROCEDURE (A: AttrLine) Draw* (F: KeplerPorts.Port);
        VAR a, b, h, v1, v2: REAL; x1, y1, x2, y2, ar, br: INTEGER;
    BEGIN
        x1 := A.p[0].x; y1 := A.p[0].y;
        x2 := A.p[1].x; y2 := A.p[1].y;
        a := x2 - x1; b := y2 - y1;
        h := Math.sqrt(a*a + b*b);
        IF h # 0 THEN
            IF A.a1 = 1 THEN v1 := ArrLen1 * A.width / (4*3*h);
                DrawArrow(F, A.p[0].x, A.p[0].y, A.p[1].x, A.p[1].y, ArrLen1 * A.width DIV 4, Math.pi / 6);
                x2 := x2 - Round(a * v1); y2 := y2 - Round(b * v1)
            ELSIF A.a1 = 2 THEN v1 := ArrLen2 * A.width / (4*3*h);
                DrawArrow(F, A.p[0].x, A.p[0].y, A.p[1].x, A.p[1].y, ArrLen2 * A.width DIV 6, Math.pi / 4);
                x2 := x2 - Round(a * v1); y2 := y2 - Round(b * v1)
            END ;
            IF A.a2 = 1 THEN v1 := ArrLen1 * A.width / (4*3*h);
                DrawArrow(F, A.p[1].x, A.p[1].y, A.p[0].x, A.p[0].y, ArrLen1 * A.width DIV 4, Math.pi / 6);
                x1 := x1 + Round(a * v1); y1 := y1 + Round(b * v1)
            ELSIF A.a2 = 2 THEN v1 := ArrLen2 * A.width / (4*3*h);
                DrawArrow(F, A.p[1].x, A.p[1].y, A.p[0].x, A.p[0].y, ArrLen2 * A.width DIV 6, Math.pi / 4);
                x1 := x1 + Round(a * v1); y1 := y1 + Round(b * v1)
            END ;
            IF A.width <= F.scale THEN (* draw as hair line *)
                F.DrawLine(x1, y1, x2, y2, Display.white, Display.replace)
            ELSIF x1 = x2 THEN (* optimized drawing of vertical line *)
                IF y1 > y2 THEN F.FillRect(x1 - A.width DIV 2, y2, A.width, y1 - y2, fg, 5, Display.replace)
                ELSE F.FillRect(x1 - A.width DIV 2, y1, A.width, y2 - y1, fg, 5, Display.replace)
                END
            ELSIF y1 = y2 THEN (* optimized drawing of horizontal line *)
                IF x1 > x2 THEN F.FillRect(x2, y2 - A.width DIV 2, x1 - x2, A.width, fg, 5, Display.replace)
                ELSE F.FillRect(x1, y1 - A.width DIV 2, x2 - x1, A.width, fg, 5, Display.replace)
                END
            ELSE v2 := A.width / (2*h);
                ar := Round(a * v2); br := Round(b * v2);
                x1 := x1 DIV F.scale * F.scale; y1 := y1 DIV F.scale * F.scale;
                x2 := x2 DIV F.scale * F.scale; y2 := y2 DIV F.scale * F.scale;
                F.FillQuad(x1 - br, y1 + ar, x1 + br, y1 - ar, x2 + br, y2 - ar, x2 - br, y2 + ar, fg, 5, Display.replace)
            END
        END
    END Draw;
    PROCEDURE (A: AttrLine) Write* (VAR R: Files.Rider);
    BEGIN Files.WriteNum(R, A.width); Files.WriteNum(R, A.a1); Files.WriteNum(R, A.a2); A.Write^(R)
    END Write;
    PROCEDURE (A: AttrLine) Read* (VAR R: Files.Rider);
        VAR i: LONGINT;
    BEGIN
        Files.ReadNum(R, i); A.width := SHORT(i);
        Files.ReadNum(R, i); A.a1 := SHORT(i);
        Files.ReadNum(R, i); A.a2 := SHORT(i);
        A.Read^(R)
    END Read;
    PROCEDURE NewAttrLine*;
        VAR a: AttrLine; w, a1, a2: INTEGER;
    BEGIN
        IF KeplerFrames.nofpts >= 2 THEN
            NEW(a); a.nofpts := 2;
            In.Open; In.Int(w); In.Int(a1); In.Int(a2);
            IF In.Done THEN
                a.width := w; a.a1 := a1; a.a2 := a2;
                KeplerFrames.ConsumePoint(a.p[0]);
                KeplerFrames.ConsumePoint(a.p[1]);
                KeplerFrames.Focus.Append(a)
            END
        END
    END NewAttrLine;
    PROCEDURE ChangeAttrLine*;
        VAR G: KeplerGraphs.Graph; c: KeplerGraphs.Constellation;
            w, a1, a2: INTEGER;
            F: KeplerPorts.BalloonPort;
    BEGIN
        In.Open;
        In.Int(w); In.Int(a1); In.Int(a2);
        KeplerFrames.GetSelection(G);
        IF (G # NIL ) & In.Done THEN
            NEW(F); KeplerPorts.InitBalloon(F);
            c := G.cons;
            WHILE c # NIL DO
                WITH c: AttrLine DO
                    IF c.State() = 2 THEN c.Draw(F); c.width := w; c.a1 := a1; c.a2 := a2 ; c.Draw(F) END
                ELSE
                END ;
                c := c.next
            END ;
            G.notify(KeplerGraphs.restore, G, NIL, F)
        END
    END ChangeAttrLine;
    PROCEDURE GetAttrLine*;
        VAR G: KeplerGraphs.Graph; c: KeplerGraphs.Constellation;
    BEGIN
        KeplerFrames.GetSelection(G);
        IF G # NIL THEN
            c := G.cons;
            WHILE c # NIL DO
                WITH c: AttrLine DO
                    IF c.State() = 2 THEN
                        Out.String("Kepler1.ChangeAttrLine "); Out.Int(c.width, 5); Out.Int(c.a1, 5); Out.Int(c.a2, 5); Out.Ln
                    END
                ELSE
                END ;
                c := c.next
            END ;
        END
    END GetAttrLine;
(* ------------------------------- Triangle ------------------------------- *)
    PROCEDURE (T: Triangle) Draw* (F: KeplerPorts.Port);
        VAR p0, p1, p2: KeplerGraphs.Star;
    BEGIN p0 := T.p[0]; p1 := T.p[1]; p2 := T.p[2];
        F.FillQuad(p0.x, p0.y, p1.x, p1.y, p2.x, p2.y, p2.x, p2.y, fg, T.pat, Display.replace)
    END Draw;
    PROCEDURE (T: Triangle) Write* (VAR R: Files.Rider);
    BEGIN Files.WriteNum(R, T.pat); T.Write^(R)
    END Write;
    PROCEDURE (T: Triangle) Read* (VAR R: Files.Rider);
        VAR i: LONGINT;
    BEGIN Files.ReadNum(R, i); T.pat := SHORT (i); T.Read^(R)
    END Read;
    PROCEDURE NewTriangle*;
        VAR o: Triangle; pat: INTEGER;
    BEGIN
        In.Open; In.Int(pat);
        IF In.Done & (KeplerFrames.nofpts >= 3) THEN
            NEW(o); o.nofpts := 3; o.pat := pat;
            KeplerFrames.ConsumePoint(o.p[0]);
            KeplerFrames.ConsumePoint(o.p[1]);
            KeplerFrames.ConsumePoint(o.p[2]);
            KeplerFrames.Focus.Append(o);
        END
    END NewTriangle;
END Kepler1.